home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / tool_inc.zip / REMPATH.INC < prev    next >
Text File  |  1989-07-18  |  4KB  |  215 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * remove_path - remove pathname prefix from a filename
  15.  *
  16.  *)
  17.  
  18. function remove_path(name: filenames): filenames;
  19.  
  20. {$IFDEF TP40}
  21.  
  22. var
  23.    n: filenames;
  24.    i: integer;
  25.  
  26. begin
  27.    if (length(name) > 2) then
  28.    begin
  29.       if (name[2] <> ':') then
  30.       begin
  31.          remove_path := name;
  32.          exit;
  33.       end
  34.       else
  35.       if name[1] > '@' then
  36.          delete(name,1,2);
  37.    end;
  38.  
  39.    n := '';
  40.    for i := 1 to length(name) do
  41.       if name[i] = '\' then
  42.          n := ''
  43.       else
  44.       begin
  45.          inc(n[0]);
  46.          n[length(n)] := name[i];
  47.       end;
  48.  
  49.    remove_path := n;
  50. end;
  51.  
  52. {$ELSE}
  53.  
  54. var
  55.    d,n,e:   filenames;
  56. begin
  57.    if ((length(name) > 2) and (name[2] <> ':') and (name[1] <> '\')) or (name[1] < 'A') then
  58.       remove_path := name
  59.    else
  60.    begin
  61.       FSplit(name,d,n,e);
  62.       remove_path := n + e;
  63.    end;
  64. end;
  65.  
  66. {$ENDIF}
  67.  
  68.  
  69. (*
  70.  * path_only - return pathname prefix from a filename
  71.  *             (does NOT include trailing \!)
  72.  *)
  73.  
  74. function path_only(name: filenames): filenames;
  75.  
  76. {$IFDEF TP40}
  77.  
  78. var
  79.    n: filenames;
  80.    i: integer;
  81.  
  82. begin
  83.  
  84.    {scan backwards looking for the last : or \ in the pathname}
  85.    n := name;
  86.    i := length(n);
  87.    while (i > 0) and (name[i] <> ':') and (name[i] <> '\') do
  88.       dec(i);
  89.  
  90.    n[0] := chr(i);
  91.  
  92.    {add a trailing "\" if needed}
  93.    if (length(n) > 2) and (n[length(n)] <> '\') then
  94.    begin
  95.       inc(n[0]);
  96.       n[length(n)] := '\';
  97.    end;
  98.  
  99.    path_only := n;
  100. end;
  101.  
  102. {$ELSE}  {TP 5.0}
  103.  
  104. var
  105.    d,n,e:   filenames;
  106.  
  107. begin
  108.    FSplit(name,d,n,e);
  109.    if d[length(d)] = '\' then
  110.       dec(d[0]);
  111.    path_only := d;
  112. end;
  113.  
  114. {$ENDIF}
  115.  
  116.  
  117. (*
  118.  * name_only - return name prefix from a filename (without path or .ext)
  119.  *)
  120.  
  121. function name_only(name: filenames): filenames;
  122. var
  123.    d,n,e:  filenames;
  124. begin
  125.    FSplit(name,d,n,e);
  126.    name_only := n;
  127. end;
  128.  
  129.  
  130. (*
  131.  * remove_ext - remove filename .ext
  132.  *
  133.  *)
  134.  
  135. function remove_ext(name: filenames): filenames;
  136. var
  137.    n: filenames;
  138.    i: integer;
  139. begin
  140.    n := name;
  141.    i := length(n);
  142.    while (i > 0) and (name[i] <> '.') do
  143.       dec(i);
  144.  
  145.    if name[i] = '.' then
  146.       n[0] := chr(i-1);
  147.  
  148.    remove_ext := n;
  149. end;
  150.  
  151.  
  152. (*
  153.  * ext_only - return only the ext portion of a filename
  154.  *
  155.  *)
  156.  
  157. function ext_only(name: filenames): filenames;
  158.  
  159. {$IFDEF TP40}
  160. var
  161.    i: integer;
  162. begin
  163.    i := length(name);
  164.    while (i > 0) and (name[i] <> '.') do
  165.       dec(i);
  166.  
  167.    if name[i] = '.' then
  168.       ext_only := copy(name,i,99)
  169.    else
  170.       ext_only := '';
  171. end;
  172.  
  173. {$ELSE}  {TP 5.0}
  174.  
  175. var
  176.    d,n,e: filenames;
  177. begin
  178.    FSplit(name,d,n,e);
  179.    ext_only := e;
  180. end;
  181.  
  182. {$ENDIF}
  183.  
  184.  
  185. (*
  186.  * cons_path - construct a pathname from a directory and a filename
  187.  *
  188.  *)
  189. procedure cons_path(var path: filenames;
  190.                     dir,name: filenames);
  191. begin
  192.    if dir[length(dir)] <> '\' then
  193.    begin
  194.       inc(dir[0]);
  195.       dir[length(dir)] := '\';
  196.    end;
  197.  
  198.    path := dir + name;
  199.    stoupper(path);
  200. end;
  201.  
  202.  
  203. (*
  204.  * cons_name - construct a filename from three parts
  205.  *
  206.  *)
  207. procedure cons_name(var resu:          filenames;
  208.                     name1,name2,ext:   filenames);
  209. begin
  210.    resu := name1 + name2 + ext;
  211.    stoupper(resu);
  212. end;
  213.  
  214.  
  215.